home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 07 - 1991 / 07.06 Jun 91 / Church Scheme Code / MT⁄combinators.sch next >
Encoding:
Text File  |  1990-04-09  |  4.6 KB  |  230 lines  |  [TEXT/EDIT]
  1. ; File:  combinators.sch.  (Eval first.)
  2. ;
  3. ; Projection functions.
  4. ;
  5. (define identity ; project-1st-of-1
  6.   (lambda (x) x))
  7. ;
  8. (define project-1st-of-2
  9.   (lambda (x)
  10.     (lambda (y)
  11.       x)))
  12. ;
  13. (define project-2nd-of-2
  14.   (lambda (x)
  15.     identity))
  16. ;
  17. (define project-3rd-of-3
  18.   (lambda (x)
  19.     (lambda (y)
  20.       identity)))
  21. ;
  22. (define 3-consumer project-3rd-of-3)
  23. ;
  24. ; Booleans and conditionals.
  25. ;
  26. (define com-true
  27.   project-1st-of-2)
  28. ;
  29. (define com-false
  30.   project-2nd-of-2)
  31. ;
  32. (define force-a-thunk ; used by com-if and others.
  33.   (lambda (thunk)
  34.     (thunk)))
  35. ;
  36. (define com-if
  37.   (lambda (condition)
  38.     (lambda (then)
  39.       (lambda (else)
  40.         (force-a-thunk ((condition then) else))))))
  41. ;
  42. (define com-not ; [Michaelson, 1989]
  43.   (lambda (x)
  44.     (((com-if x)
  45.       (lambda () com-false))
  46.      (lambda () com-true))))
  47. ;
  48. (define com-and ; [Field, 1989]
  49.   (lambda (x)
  50.     (lambda (y)
  51.       ((x y) com-false))))
  52. ;
  53. (define com-or ; [Field, 1989]
  54.   (lambda (x)
  55.     (lambda (y)
  56.       ((x com-true) y))))
  57. ;
  58. ; List primitives.
  59. ;
  60. (define com-cons
  61.   (lambda (x)
  62.     (lambda (y)
  63.       (lambda (selector)
  64.         ((selector x) y)))))
  65. ;
  66. (define com-car
  67.   (lambda (object)
  68.     (object project-1st-of-2)))
  69. ;
  70. (define com-cdr
  71.   (lambda (object)
  72.     (object project-2nd-of-2)))
  73. ;
  74. (define com-nil ; project-2nd-of-3
  75.   (lambda (x)   ; [Field, 1989]
  76.     com-true))  ;
  77. ;
  78. (define com-null? ; [Field, 1989]
  79.   (lambda (tuple)
  80.     (tuple (lambda (head)
  81.              (lambda (tail)
  82.                com-false)))))
  83. ;
  84. ; Y combinator.
  85. ;
  86. (define applicative-order-y
  87.   (lambda (f)
  88.     ((lambda (x) (f (lambda (arg) ((x x) arg))))
  89.      (lambda (x) (f (lambda (arg) ((x x) arg)))))))
  90. ;
  91. ; The Mother of All Church numerals.
  92. ;
  93. (define com-zero
  94.   project-2nd-of-2)
  95. ;
  96. ; Church numeral predicates.
  97. ;
  98. (define com-zero?
  99.   (lambda (n)
  100.     (((unravel n) 3-consumer) com-true)))
  101. ;
  102. (define com-even? ; [Révész, 1988] (not in book)
  103.   (lambda (n)
  104.     (((unravel n) com-not) com-true)))
  105. ;
  106. (define com-odd? ; [Révész, 1988] (not in book)
  107.   (lambda (n)
  108.     (((unravel n) com-not) com-false)))
  109. ;
  110. (define com-<? ; [vanMeule]
  111.   (applicative-order-y
  112.    (lambda (less-than?)
  113.      (lambda (x)
  114.        (lambda (y)
  115.          (((com-if (com-zero? x))
  116.            (lambda () 
  117.              (((com-if (com-zero? y))
  118.                (lambda () com-false))
  119.               (lambda () com-true))))
  120.           (lambda () 
  121.             (((com-if (com-zero? y))
  122.               (lambda () com-false))
  123.              (lambda () ((less-than? (com-pred x))
  124.                          (com-pred y)))))))))))
  125. ;
  126. ; Church numeral operators.
  127. ;
  128. (define com-succ
  129.   (lambda (n)
  130.     (lambda (f)
  131.       (lambda (x)
  132.         (f (((unravel n) f) x))))))
  133. ;
  134. (define make-ascending-tuple ; part of pred
  135.   (lambda (tuple)
  136.     ((com-cons 
  137.       (com-cdr tuple))
  138.      (com-succ (com-cdr tuple)))))
  139. ;  
  140. (define initial-pred-tuple ; part of pred
  141.   ((com-cons "com-pred called on 0")
  142.    com-zero))
  143. ;
  144. (define com-pred
  145.   (lambda (n)
  146.     (com-car 
  147.      (((unravel n) 
  148.        make-ascending-tuple)
  149.       initial-pred-tuple))))
  150. ;
  151. (define com-add ; Révész version [Révész, 1988]
  152.   (lambda (m)
  153.     (lambda (n)
  154.       (lambda (f)
  155.         (lambda (x)
  156.           ((m f)
  157.            ((n f) x)))))))
  158. ;
  159. (define com-add ; [vanMeule]
  160.   (lambda (m)
  161.     (lambda (n)
  162.       (lambda (f)
  163.         (lambda (x)
  164.           (((unravel (((unravel n) com-succ) m)) 
  165.             f) x))))))
  166. ;
  167. (define com-sub ; [vanMeule]
  168.   (lambda (m)
  169.     (lambda (n)
  170.       (lambda (f)
  171.         (lambda (x)
  172.           (((unravel (((unravel n) com-pred) m)) 
  173.             f) x))))))
  174. ;
  175. (define com-mul
  176.   (lambda (m)
  177.     (lambda (n)
  178.       (lambda (f)
  179.         ((partial-unravel m) 
  180.          ((partial-unravel n) f))))))
  181. ;
  182. (define com-quo ; [vanMeule]
  183.   (applicative-order-y
  184.    (lambda (the-quo)
  185.      (lambda (dividend)
  186.        (lambda (divisor)
  187.          (((com-if ((com-<? dividend) divisor))
  188.            (lambda () com-zero))
  189.           (lambda () 
  190.             (com-succ ((the-quo ((com-sub dividend) 
  191.                                  divisor)) 
  192.                        divisor)))))))))
  193. ;
  194. (define com-rem) ; Reader defines remainder.
  195. ;
  196. (define com-pow ; [Katz, 1988]
  197.   (lambda (m)
  198.     (lambda (n)
  199.       ((partial-unravel n) m))))
  200. ;
  201. ; Church numeral utility functions.
  202. ;
  203. (define number->church ; make-church-numeral
  204.   (lambda (n)
  205.     (if (zero? n)
  206.         com-zero
  207.         (com-succ 
  208.          (number->church (- n 1))))))
  209. ;
  210. (define unravel
  211.   (lambda (n)
  212.     (lambda (f)
  213.       (lambda (x)
  214.         ((n f) x)))))
  215. ;
  216. (define partial-unravel
  217.   (lambda (n)
  218.     (lambda (f)
  219.       (n f))))
  220. ;
  221. (define church->number ; dechurchify-numeral
  222.   (lambda (church-numeral)
  223.     (((unravel church-numeral) 1+) 0)))
  224. ;
  225. (define com-one 
  226.   (lambda (f)
  227.     (lambda (x)
  228.       (f x))))
  229. ;
  230. 'done